home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / UTILITY1 / MSWSRC35.ZIP / EVAL.CPP < prev    next >
C/C++ Source or Header  |  1993-08-19  |  27KB  |  928 lines
  1. /*
  2.  *      eval.c          logo eval/apply module                  dko
  3.  *
  4.  *    Copyright (C) 1992 The Regents of the University of California
  5.  *    This Software may be copied and distributed for educational,
  6.  *    research, and not for profit purposes provided that this
  7.  *    copyright and statement are included in all such copies.
  8.  *
  9.  */
  10.  
  11. #include "logo.h"
  12. #include "globals.h"
  13. #ifdef unix
  14. #include <sgtty.h>
  15. #endif
  16.  
  17. #ifndef TIOCSTI
  18. #include <setjmp.h>
  19. extern jmp_buf iblk_buf;
  20. #endif
  21.  
  22. #define assign(to, from)    (to = reref(to, from))
  23. #define init(to, from)        (to = valref(from))
  24.  
  25. #define save(register)        push(register, stack)
  26. #define restore(register)   (assign(register, car(stack)), pop(stack))
  27.  
  28. #define save2(reg1,reg2)    (push(reg1,stack),setobject(stack,reg2))
  29. #define restore2(reg1,reg2) (assign(reg2,getobject(stack)), \
  30.                  assign(reg1,car(stack)), pop(stack))
  31.  
  32. /* saving and restoring FIXNUMs rather than NODEs */
  33.  
  34. #define numsave(register)   numpush(register, &stack)
  35. #define numrestore(register) (register=(FIXNUM)car(stack), numpop(&stack))
  36.  
  37. #define num2save(reg1,reg2) (numpush(reg1,&stack),stack->n_obj=(NODE *)reg2)
  38. #define num2restore(reg1,reg2) (reg2=(FIXNUM)getobject(stack), \
  39.                 reg1=(FIXNUM)car(stack), numpop(&stack))
  40.  
  41. /* save and restore a FIXNUM (reg1) and a NODE (reg2) */
  42.  
  43. #define mixsave(reg1,reg2)  (numpush(reg1,&stack),setobject(stack,reg2))
  44. #define mixrestore(reg1,reg2) deref(reg2); reg2=getobject(stack); \
  45.                    reg1=(FIXNUM)car(stack); numpop(&stack)
  46.  
  47. #define newcont(tag)        (numsave(cont), cont = (FIXNUM)tag)
  48.  
  49. #define nameis(x,y)        ((object__caseobj(x)) == (object__caseobj(y)))
  50.  
  51. typedef NODE *(*nodeinout)(NODE *arg);
  52.  
  53. /* These variables are all externed in globals.h */
  54.  
  55. NODE
  56. *fun        = NIL,  /* current function name */
  57. *ufun        = NIL,    /* current user-defined function name */
  58. *last_ufun    = NIL,    /* the function that called this one */
  59. *this_line    = NIL,    /* the current instruction line */
  60. *last_line    = NIL,    /* the line that called this one */
  61. *var_stack    = NIL,    /* the stack of variables and their bindings */
  62. *var        = NIL,    /* frame pointer into var_stack */
  63. *last_call    = NIL,    /* the last proc called */
  64. *didnt_output_name = NIL,   /* the name of the proc that didn't OP */
  65. *didnt_get_output  = NIL,   /* the name of the proc that wanted the OP */
  66. *output_node    = NIL;    /* the output of the current function */
  67.  
  68.  
  69. FIXNUM global_repcount[128];        /* count for repeat */
  70. FIXNUM global_repcount_index = 0;        /* count for repeat */
  71. CTRLTYPE    stopping_flag = RUN;
  72. char        *logolib;
  73. FIXNUM        tailcall; /* 0 in sequence, 1 for tail, -1 for arg */
  74. FIXNUM        val_status;        /* 0 means no value allowed (body of cmd),
  75.                    1 means value required (arg),
  76.                    2 means OUTPUT ok (body of oper),
  77.                    3 means val or no val ok (fn inside catch),
  78.                    4 means no value in macro (repeat),
  79.                    5 means value maybe ok in macro (catch)
  80.                  */
  81.  
  82. FIXNUM      dont_fix_ift = 0;
  83.  
  84. /* These variables are local to this file. */
  85. static NODE *qm_list = NIL;    /* question mark list */
  86. static int trace_level = 0;    /* indentation level when tracing */
  87.  
  88. /* These first few functions are externed in globals.h */
  89.  
  90. void spop(NODE **stack) {
  91.     NODE *temp = (*stack)->n_cdr;
  92.  
  93.     if (decrefcnt(*stack) == 0) {
  94.     (*stack)->n_cdr = NIL;
  95.     gc(*stack);
  96.     } else {
  97.     if (temp != NIL) increfcnt(temp);
  98.     }
  99.     *stack = temp;
  100. }
  101.  
  102. void spush(NODE *obj, NODE **stack) {
  103.     NODE *temp = newnode(CONS);
  104.  
  105.     setcar(temp, obj);
  106.     temp->n_cdr = *stack;
  107.     ref(temp);
  108.     *stack = temp;
  109. }
  110.  
  111. void numpop(NODE **stack) {
  112.     NODE *temp = (*stack)->n_cdr;
  113.  
  114.     (*stack)->n_car = NIL;
  115.     (*stack)->n_cdr = NIL;
  116.     (*stack)->n_obj = NIL;
  117.     deref(*stack);
  118.     *stack = temp;
  119. }
  120.  
  121. void numpush(FIXNUM obj, NODE **stack) {
  122.     NODE *temp = newnode(CONS);
  123.  
  124.     temp->n_car = (NODE *)obj;
  125.     temp->n_cdr = *stack;
  126.     ref(temp);
  127.     *stack = temp;
  128. }
  129.  
  130. /* forward declaration */
  131. NODE *evaluator(NODE *list, enum labels where);
  132.  
  133. /* Evaluate a line of input. */
  134. void eval_driver(NODE *line) {
  135.     evaluator(line, begin_line);
  136. }
  137.  
  138. /* Evaluate a sequence of expressions until we get a value to return.
  139.  * (Called from erract.)
  140.  */ 
  141. NODE *err_eval_driver(NODE *seq) {
  142.     val_status = 5;
  143.     return evaluator(seq, begin_seq);
  144. }
  145.  
  146. /* The logo word APPLY. */
  147. NODE *lapply(NODE *args) {
  148.     return make_cont(begin_apply, args);
  149. }
  150.  
  151. /* The logo word ? <question-mark>. */
  152. NODE *lqm(NODE *args) {
  153.     FIXNUM argnum = 1, i;
  154.     NODE *np = qm_list;
  155.  
  156.     if (args != NIL) argnum = getint(pos_int_arg(args));
  157.     if (stopping_flag == THROWING) return(UNBOUND);
  158.     i = argnum;
  159.     while (--i > 0 && np != NIL) np = cdr(np);
  160.     if (np == NIL)
  161.     return(err_logo(BAD_DATA_UNREC,make_intnode(argnum)));
  162.     return(car(np));
  163. }
  164.  
  165. /* The rest of the functions are local to this file. */
  166.  
  167. /* Warn the user if a local variable shadows a global one. */
  168. void tell_shadow(NODE *arg) {
  169.     if (flag__caseobj(arg, VAL_STEPPED))
  170.     err_logo(SHADOW_WARN, arg);
  171. }
  172.  
  173. /* Check if a local variable is already in this frame */
  174. int not_local(NODE *name, NODE *sp) {
  175.     for ( ; sp != var; sp = cdr(sp)) {
  176.     if (compare_node(car(sp),name,TRUE) == 0) {
  177.         return FALSE;
  178.     }
  179.     }
  180.     return TRUE;
  181. }
  182.  
  183. /* reverse a list destructively */
  184. NODE *reverse(NODE *list) {
  185.     NODE *ret = NIL, *temp;
  186.  
  187.     ref(list);
  188.     while (list != NIL) {
  189.     temp = list;
  190.     list = cdr(list);
  191.     temp->n_cdr = ret;
  192.     ret = temp;
  193.     }
  194.     return unref(ret);
  195. }
  196.  
  197. /* nondestructive append */
  198. NODE *append(NODE *a, NODE *b) {
  199. //    NODE *result;
  200.  
  201.     if (a == NIL) return b;
  202.     return cons(car(a), append(cdr(a), b));
  203. }
  204.  
  205. /* Reset the var stack to the previous place holder.
  206.  */
  207. void reset_args(NODE *old_stack) {
  208.     for (; var_stack != old_stack; pop(var_stack))
  209.     setvalnode__caseobj(car(var_stack), getobject(var_stack));
  210. }
  211.  
  212. /* An explicit control evaluator, taken almost directly from SICP, section
  213.  * 5.2.  list is a flat list of expressions to evaluate.  where is a label to
  214.  * begin at.  Return value depends on where.
  215.  */ 
  216. NODE *evaluator(NODE *list, enum labels where) {
  217.  
  218.     /* registers */
  219.     NODE    *exp    = NIL,  /* the current expression */
  220.         *val    = NIL,  /* the value of the last expression */
  221.         *proc   = NIL,  /* the procedure definition */
  222.         *argl   = NIL,  /* evaluated argument list */
  223.         *unev   = NIL,  /* list of unevaluated expressions */
  224.         *stack  = NIL,  /* register stack */
  225.         *parm   = NIL,  /* the current formal */
  226.         *catch_tag = NIL,
  227.         *arg    = NIL;  /* the current actual */
  228.  
  229. //    NODE    *tmpval = NIL;  /* */
  230.  
  231. /* registers that don't get reference counted, so we pretend they're ints */
  232. FIXNUM        vsp    = 0,        /* temp ptr into var_stack */
  233.         cont   = 0,        /* where to go next */
  234.         formals = (FIXNUM)NIL; /* list of formal parameters */
  235.  
  236.     int i;
  237. //    int nargs;
  238.     BOOLEAN tracing;        /* are we tracing the current procedure? */
  239.     FIXNUM oldtailcall;        /* in case of reentrant use of evaluator */
  240.     FIXNUM repcount;        /* count for repeat */
  241.     FIXNUM old_ift_iff;
  242.     
  243.     oldtailcall = tailcall;
  244.     old_ift_iff = ift_iff_flag;
  245.     save2(var,this_line);
  246.     assign(var, var_stack);
  247.     save2(fun,ufun);
  248.     cont = (FIXNUM)all_done;
  249.     numsave((FIXNUM)cont);
  250.     newcont(where);
  251.     goto fetch_cont;
  252.     
  253. begin_line:
  254.     ref(list);
  255.     assign(this_line, list);
  256.     newcont(end_line);
  257. begin_seq:
  258.     make_tree(list);
  259.     if (!is_tree(list)) {
  260.     assign(val, UNBOUND);
  261.     goto fetch_cont;
  262.     }
  263.     assign(unev, tree__tree(list));
  264.     assign(val, UNBOUND);
  265.     goto eval_sequence;
  266.  
  267. end_line:
  268.     if (val != UNBOUND) {
  269.     if (NOT_THROWING) err_logo(DK_WHAT, val);
  270.     deref(val);
  271.     }
  272.     val = NIL;
  273.     deref(list);
  274.     goto fetch_cont;
  275.  
  276.  
  277. /* ----------------- EVAL ---------------------------------- */
  278.  
  279. tail_eval_dispatch:
  280.     tailcall = 1;
  281. eval_dispatch:
  282.     switch (nodetype(exp)) {
  283.     case QUOTE:            /* quoted literal */
  284.         assign(val, node__quote(exp));
  285.         goto fetch_cont;